home *** CD-ROM | disk | FTP | other *** search
Option Explicit ' 'prevent needless paints Dim resizing% 'global constants for list boxes Global Const LISTTEXTLEFT = 44 Global Const LISTITEMHEIGHT = 36 'types for Progman windows================ 'constant size data for all PMwindows 'for this sample, all common values are placed in a seperate structure 'to reduce duplication of data Type COMMONDATA cell As PointAPI 'w,h of normal cell pic As PointAPI 'x,y offset of cell image cap As rect 'x,y offset,r,b offset of caption 'control panel colors bkg As Long 'window background color txt As Long 'window text hilite As Long ' hilitetext As Long ' End Type Global cdata As COMMONDATA 'variable data for each window - each instance of the list is created 'by declaring a listdata structure Type LISTDATA toprow As Integer 'client area's top itemcount As Integer 'total items active As Integer 'active item cols As Integer rows As Integer visrows As Integer width As Integer End Type 'used to transfer data between windows Global gItem As ITEMDATA 'API constants and types==================== Global Const black = &H0 Global Const white = &HFFFFFF Global Const lgrey = &HC0C0C0 Global Const PATPAINT = &HFB0A09 Global Const PATCOPY = &HF00021 Global Const SRCCOPY = &HCC0020 Global Const GWW_HINSTANCE = (-6) Global Const WM_USER = &H400 Global Const GWL_STYLE = (-16) 'draw text Global Const DT_CALCRECT = &H400 Global Const DT_CENTER = &H1 Global Const DT_NOPREFIX = &H800 Global Const DT_VCENTER = &H4 Global Const DT_WORDBREAK = &H10 Global Const DT_INTERNAL = &H1000 Global Const DT_SINGLELINE = &H20 Global Const DT_LEFT = &H0 Global Const DT_GETRECT = DT_CALCRECT Or DT_NOPREFIX Or DT_CENTER Or DT_WORDBREAK Global Const DT_ICONCAP = DT_NOPREFIX Or DT_WORDBREAK Or DT_CENTER Global Const DT_LISTCAP = DT_NOPREFIX Or DT_LEFT ' Or DT_WORDBREAK Or DT_SINGLELINE Global Const DT_ICONTITLE = DT_NOPREFIX Or DT_CENTER Or DT_WORDBREAK 'Or DT_VCENTER Declare Function bitblt% Lib "GDI" (ByVal hDestDC%, ByVal x%, ByVal y%, ByVal nWidth%, ByVal nHeight%, ByVal hSrcDC%, ByVal XSrc%, ByVal YSrc%, ByVal dwRop&) Declare Function CreateDC Lib "GDI" (ByVal lpDriverName As String, ByVal lpDeviceName As Any, ByVal lpOutput As Any, ByVal lpInitData As Any) As Integer Declare Function CreateSolidBrush% Lib "GDI" (ByVal crColor&) Declare Function DeleteDC Lib "GDI" (ByVal hDC As Integer) As Integer Declare Function DeleteObject% Lib "GDI" (ByVal hObject%) Declare Function DrawText% Lib "User" (ByVal hDC%, ByVal lpStr$, ByVal nCount%, lpRect As rect, ByVal wFormat%) Declare Function DrawIcon Lib "USER" (ByVal lpHandle As Integer, ByVal xcoord As Integer, ByVal ycoord As Integer, ByVal hicon As Integer) As Integer Declare Function ExtractIcon Lib "shell" (ByVal lpHandle As Integer, ByVal lpExe As String, ByVal lpiconindex As Integer) As Integer Declare Function GetSysColor& Lib "User" (ByVal nIndex%) Declare Function GetWindowWord Lib "User" (ByVal hWnd As Integer, ByVal nIndex As Integer) As Integer Declare Function SetTextColor& Lib "GDI" (ByVal hDC%, ByVal crColor&) Declare Function PatBlt% Lib "GDI" (ByVal hDC%, ByVal x%, ByVal y%, ByVal nWidth%, ByVal nHeight%, ByVal dwRop&) Declare Function SelectObject% Lib "GDI" (ByVal hDC%, ByVal hObject%) Sub InitList (F As Form, ld As LISTDATA) Dim inst%, i%, s$ F.BackColor = cdata.bkg F.ForeColor = cdata.txt ld.toprow = 0 ld.active = 1 End Sub Sub ItemClick (F As Form, ld As LISTDATA, id() As ITEMDATA, y) Dim n%, old% Dim textr As rect, cr As rect '===set focus to clicked item===================== y = (y) \ LISTITEMHEIGHT: 'Debug.Print x, y 'determine relative item # n = y + 1'Debug.Print n 'determine absolute item # n = n + ld.toprow'Debug.Print n 'set active item If n <= ld.itemcount Then 'old is a 1-based index; the draw routine uses a 0-base old% = ld.active - 1 ld.active = n End If 'erase old hilite textr.left = LISTTEXTLEFT textr.right = ld.width - textr.left cr.left = LISTTEXTLEFT - 8 cr.right = ld.width 'valid index? If old >= 0 And old < ld.itemcount Then 'is it still visible? n = old - ld.toprow If n >= 0 And n < ld.visrows Then 'size of caption rect: textr.top = n * LISTITEMHEIGHT + 8 textr.bottom = (n + 1) * LISTITEMHEIGHT ' 'size of hilite rect cr.top = textr.top - 8 cr.bottom = cr.top + LISTITEMHEIGHT PaintHilite F, 0, id(old + 1).cap, textr, cr End If End If 'draw new hilite n = ld.active - 1 - ld.toprow: 'Debug.Print "rel" & n 'check if its visible:'Debug.Print "total" & ld.visrows * ld.cols If n < 0 Or n > ld.visrows - 1 Then Exit Sub 'size of caption rect: textr.top = n * LISTITEMHEIGHT + 8 textr.bottom = textr.top + 24: 'Debug.Print cr.left, cr.top, cr.right, cr.bottom cr.top = textr.top - 8 cr.bottom = cr.top + LISTITEMHEIGHT PaintHilite F, -1, id(ld.active).cap, textr, cr End Sub Sub LoadIcons (F As Form, ld As LISTDATA, id() As ITEMDATA) Dim inst%, i%, r% mnu.loader.Picture = LoadPicture() F.pics.Cls inst% = GetWindowWord(F.hWnd, GWW_HINSTANCE) 'extract the icon for each item and put them all into 'a single bitmap F.pics.Move 0, 0, ld.itemcount * 32, 32 For i% = 1 To ld.itemcount GetIcon id(i).iconpath, id(i).iconindex r = bitblt(F.pics.hDC, (i - 1) * 32, 0, 32, 32, mnu.loader.hDC, 0, 0, SRCCOPY) Next End Sub Sub PaintHilite (F As Form, op%, s$, tr As rect, cr As rect) Dim bkgcolor&, txtcolor&, r% Dim offset%'offset of icon caption Dim hbrOld%, hbr%, cOld& 'api stuff ' 'n = 0 erase hilite; n = -1 paint hilite If op Then bkgcolor& = cdata.hilite txtcolor& = cdata.hilitetext Else bkgcolor& = cdata.bkg txtcolor = cdata.txt End If 'paint a hilite rectangle: hbr = CreateSolidBrush(bkgcolor&) hbrOld = SelectObject(F.hDC, hbr) r = PatBlt(F.hDC, cr.left, cr.top, cr.right - cr.left, cr.bottom - cr.top, PATCOPY) F.Line (0, cr.top)-(36, cr.top + 35), bkgcolor&, B 'paint hilite text: cOld = SetTextColor(F.hDC, txtcolor&) r = DrawText(F.hDC, s, Len(s), tr, DT_LISTCAP) 'cleanup cOld = SetTextColor(F.hDC, cOld) hbr = SelectObject(F.hDC, hbrOld) r = DeleteObject(hbr) End Sub Sub PaintList (F As Form, ld As LISTDATA, id() As ITEMDATA) Dim i%, r% Dim y% 'y pos to draw icon Dim ypos% 'y pos of item Dim pstart%, pend% 'indexes of first and last visible icons Dim cr As rect, tr As rect 'for drawing text 'calculate which icons to show: pstart% = ld.toprow + 1': Debug.Print pstart pend% = pstart% + ld.visrows - 1 If pend% > ld.itemcount Then pend% = ld.itemcount': Debug.Print pend ' 'draw the icons: y = -LISTITEMHEIGHT + 2 For i = pstart% To pend% y = y + LISTITEMHEIGHT'(new row) r = bitblt(F.hDC, 2, y, 32, 32, F.pics.hDC, (i - 1) * 32, 0, SRCCOPY) Next y = -LISTITEMHEIGHT tr.left = LISTTEXTLEFT tr.right = ld.width' - tr.left For i = pstart% To pend% y = y + LISTITEMHEIGHT'(new row) 'define the rect to draw text in: tr.top = y + 8 tr.bottom = y + LISTITEMHEIGHT ' If i = ld.active Then cr.left = tr.left - 8 cr.top = y cr.bottom = y + LISTITEMHEIGHT cr.right = F.ScaleWidth PaintHilite F, -1, id(i).cap, tr, cr Else r = DrawText(F.hDC, id(i).cap, Len(id(i).cap), tr, DT_LISTCAP) End If Next Exit Sub ' paintlisterr: MsgBox "Err: " & Err & nl & Error(Err), , "UNABLE TO PAINT WINDOW" Exit Sub End Sub Sub ResizeList (F As Form, ld As LISTDATA) 'Dim x%, y% 'Dim r As rect Debug.Print "Resizing" resizing = -1 ' ld.rows = ld.itemcount If ld.rows < 1 Then ld.rows = 1 ld.cols = 1 ld.visrows = F.ScaleHeight \ LISTITEMHEIGHT + 1: Debug.Print ld.rows, ld.visrows F.vs.Visible = 0 ' If ld.rows > ld.visrows Then F.vs.Move F.ScaleWidth - F.vs.Width, 0, F.vs.Width, F.ScaleHeight F.vs.Visible = -1 F.vs.Max = ld.rows - ld.visrows Else ld.toprow = 0 F.vs.Visible = 0 End If ld.width = F.ScaleWidth ' resizing = 0 End Sub Sub SetColor () cdata.bkg = GetSysColor(5) cdata.txt = GetSysColor(8) cdata.hilite = GetSysColor(13) cdata.hilitetext = GetSysColor(14) End Sub Sub SetScaleData () Dim i%, l& tx = screen.TwipsPerPixelX ty = screen.TwipsPerPixelY 'set constants for all 'window' forms cdata.cell.x = 100 cdata.cell.y = 80 cdata.pic.x = 32 cdata.pic.y = 8 cdata.cap.left = 2 cdata.cap.top = 40 cdata.cap.right = cdata.cell.x - 2 * cdata.cap.left cdata.cap.bottom = cdata.cell.y - cdata.cap.top ' End Sub 
